PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/basic/apg_2.exe/PHONE1.S&M

Text File | 1993-03-18 | 5.1 KB | 228 lines

''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                '
'                Phone List by Name              '
'                                                '
'                 CREATED BY APG                 '
'                 S & M SOFTWARE                 '
'                 COPYRIGHT 1993                 '
'                                                '
'         USE files are PHONE.USE and .US1       '
'                                                '
'  Author: S&M Software                          '
'  Date:   03-18-1993                            '
'  Time:   10:44:54                              '
'                                                '
'  USE file Created         USE file Modified    '
'  Date:   03-10-1993       Date:   03-14-1993   '
'  Time:   22:50:08         Time:   11:18:01     '
''''''''''''''''''''''''''''''''''''''''''''''''''

DEFINT A-Z
DECLARE SUB box ()
DECLARE SUB header ()
DECLARE SUB sortindex ()
TYPE rectype                                'Define variables for file
   pnbr AS STRING * 12
   xName20 AS STRING * 30
   xAddress AS STRING * 25
   xcity40 AS STRING * 20
   xstate50 AS STRING * 2
   xZip60 AS STRING * 10
   xSpouse AS STRING * 10
   xData80 AS STRING * 8
   xGift90 AS INTEGER
   sts AS STRING * 1
END TYPE
TYPE indextype                              'Define index
   recnum AS INTEGER
   sort AS STRING * 30
END TYPE
DIM SHARED pline
DIM SHARED page
DIM SHARED numofrec
DIM SHARED phone AS rectype

ON ERROR GOTO errhandle

OPEN "PHONE.DAT" FOR RANDOM AS #1 LEN = LEN(phone)

numofrec = LOF(1) \ LEN(phone)
IF numofrec = 0 THEN
   CLS
   PRINT "You have to build the Data Base first."
   INPUT "", a$
   GOTO fina
END IF
DIM SHARED index(1 TO numofrec)  AS indextype
FOR i = 1 TO numofrec
   GET #1, i, phone
   index(i).recnum = i
   index(i).sort = UCASE$(phone.xName20)
NEXT i

COLOR , 1
CLS
COLOR 4, 1
LOCATE 1, 25
PRINT STRING$(30, 220)
LOCATE 2, 24
COLOR , 0
PRINT " ";
COLOR 0, 3
PRINT STRING$(30, " ")
LOCATE 2, 31
COLOR 0, 3: PRINT "Phone List by Name"
LOCATE 3, 24
COLOR , 0: PRINT STRING$(30, " ")

COLOR 7, 1
LOCATE 5, 26
PRINT "Date: "; DATE$; "    "; TIME$
LOCATE 6, 26
PRINT "Program name:       "; "PHONE1  "
LOCATE 7, 26
PRINT "Data file name:     "; "PHONE.DAT"
LOCATE 8, 26
PRINT "Number of records: "; numofrec

box
COLOR 0, 3
LOCATE 11, 26
PRINT "Please check to see that the"
LOCATE 12, 26
PRINT "printer has paper and is "
LOCATE 13, 26
PRINT "on-line.  A)bort, or <ENTER>"

DO
a$ = INKEY$
LOOP WHILE a$ = ""
IF UCASE$(a$) = "A" GOTO fina

box
LOCATE 12, 27
PRINT "Sorting file - Please wait"
sortindex
box

first$ = "F"
FOR i = 1 TO numofrec
IF pline <= 0 THEN
   IF first$ = "" THEN LPRINT CHR$(12)
   header
END IF
GET #1, index(i).recnum, phone
IF phone.sts = "D" THEN GOTO nex
LPRINT TAB(1); phone.xName20;
LPRINT TAB(32); phone.pnbr;
LPRINT TAB(45); phone.xcity40;
LPRINT TAB(66); phone.xSpouse

a$ = INKEY$
IF a$ = CHR$(27) THEN GOTO fin

first$ = ""
pline = pline - 1
nex:
NEXT i
fin:

LPRINT CHR$(12);                                'Form Feed
fina:
COLOR 7, 1
CLS
CLOSE
END

errhandle:
IF ERR = 25 THEN
   box
   LOCATE 12, 32
   PRINT "Printer Not ready"
   LOCATE 13, 32
   PRINT "Abort or Retry "
   DO
      a$ = INKEY$
   LOOP WHILE a$ = ""
   IF UCASE$(a$) = "R" THEN
      box
      LOCATE 12, 32
      PRINT "Printing Page:"; page
      LOCATE 13, 32
      PRINT "<Escape> to cancel"
      RESUME
   ELSE
      GOTO fina
   END IF
ELSE
   CLS
   PRINT "Unexpected error number"; ERR
   PRINT "Please consult your Quickbasic Manual"
   INPUT "", a$
   GOTO fina
END IF

SUB box
COLOR 4, 1
LOCATE 10, 25
PRINT STRING$(30, 220)
COLOR 9, 7
LOCATE 11, 24
COLOR 0: PRINT CHR$(219); : COLOR , 3: PRINT STRING$(30, " ")'219)
LOCATE 12, 24
COLOR 0: PRINT CHR$(219); : COLOR , 3: PRINT STRING$(30, " ")'219)
LOCATE 13, 24
COLOR 0: PRINT CHR$(219); : COLOR , 3: PRINT STRING$(30, " ")'219)
LOCATE 14, 24
COLOR 0: PRINT STRING$(30, 219)
END SUB

SUB header
first$ = ""
page = page + 1
LOCATE 12, 32
PRINT "Printing Page:"; page
LOCATE 13, 31
PRINT "<Escape> to cancel"
IF first$ = "" THEN
   first$ = "F"
END IF

LPRINT TAB(2); "Run date: "; DATE$; " "; TIME$;
LPRINT TAB(70); "Page:"; page
LPRINT TAB(2); "Program name: PHONE1";
LPRINT TAB(31); "Phone List by Name"
LPRINT ""

LPRINT TAB(1); "Name";
LPRINT TAB(32); "Phone";
LPRINT TAB(45); "City";
LPRINT TAB(66); "Spouse"

LPRINT TAB(32); "Number";
LPRINT TAB(66); "Name"
LPRINT STRING$(80, "=")
pline = 51
END SUB

SUB sortindex STATIC
SHARED index() AS indextype, numofrec
offset = numofrec \ 2
DO WHILE offset > 0
   limit = numofrec - offset
   DO
      switch = FALSE
      FOR i = 1 TO limit
         IF UCASE$(index(i).sort) > UCASE$(index(i + offset).sort) THEN
            SWAP index(i), index(i + offset)
            switch = i
         END IF
      NEXT i
      limit = switch
   LOOP WHILE switch
   offset = offset \ 2
LOOP

END SUB